COMMENT ⊗   VALID 00018 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00003 00002	.SBTTL SMALL BLOCK ALLOCATOR
C00008 00003	 Definitions of fields
C00011 00004	 DEFSPC
C00013 00005	 DATA AREA
C00014 00006	 MAPPTR, MKRTJM, MARKR0, LNKMTH
C00021 00007	 MARKPH, MKROUT
C00023 00008	ROUTINE CPFYSP,<SPC>
C00027 00009	ROUTINE CPFY
C00029 00010	 SWEEP
C00032 00011	 GC, NOGC, YESGC
C00034 00012	 GETSBK, GETBLK, GETSID, PTRSID
C00038 00013	 FREBLK, FRESBK
C00040 00014	 NEWSPC, SETSPC
C00042 00015	 ADDBUF
C00044 00016	 Standard spaces, SBINIT, Marking methods: MCELL, MARKQ
C00050 00017	.IFNZ	SMBDBG		Test routine
C00052 00018	 Known bugs
C00054 ENDMK
C⊗;
.SBTTL SMALL BLOCK ALLOCATOR
;Coded by RHT 9-Sept-1974

SMBDBG == 0	;1 => WE ARE DEBUGGING (PUT IN TEST ROUTINE)

COMMENT ⊗

Overview: The basic idea is to break up large blocks of storage into
smaller, fixed size blocks, and then administer them.  The routines
given here provide a facility whereby a user can have a number of
different "spaces" of fixed size blocks.  Each space is described by
an approximately 10 word space descriptor.  All these space
descriptors are linked together on a big chain (SIDLST), and each
space is assumed to have asociated with it a unique 8-bit number
(thus allowing up to 256 spaces).  Each space descriptor owns a
linked list of buffers; each buffer contains a number of blocks.
Each space may be either collectable or uncollectable.  Any block may
be released explicitly, although if the space is collectable, this
may be unwise.  Also, collectable spaces are compactified by the
garbage collector.  As an efficiency measure, the first few indices
[of what? - RF] (now, 1-10) are also kept in a table (SIDTBL). 
 
 Blocks are allocated by the routines GETBLK & GETSBK:
 
 	MOV	#IDCODE,R0	 ;IDCODE is the 8-bit code for a space
 	JSR	PC,GETBLK	 ;
 
 	MOV	#SPCDSC,R0	 ;SPCDSC is the address of the space
 	JSR	PC,GETSBK	 ;descriptor
 
In either case, a pointer to a new block is returned in R0.  If need
be, the free space routine will call the garbage collector to get
more space or (if the space is not collectable or garbage collection
is disabled) it will call the large block routines to get another
buffer.  If garbage collection fails to produce a goodly surplus of
blocks for some space, then additional buffers of new blocks will be
obtained. 
 
Each small block has the following format:

 		TAB,,ID		 tag is used in garbage collecting
 	R0 →→	WORD 0		 this is the word pointed to by getblk
 		:
 		WORD n
 
Blocks are zeroed before being returned.  Although this is sometimes
a bit extra overhead, it does prevent bugs and avoids the necessity
for explicit clears all over the place. 
 
Blocks are freed by the routines FREBLK & FRESBK:
 
 	MOV	BLOCK,R0	 ;R0 ← block to free
 	JSR	PC,FREBLK
 
 	MOV	BLOCK,R0	 ;R0 ← block to free
 	MOV	#SPCDSC,R1	 ;R1 ← space descriptor
 	JSR	PC,FRESBK
 
The macro 
 	 DEFSPC ID,MMRT,SZ,NPB,GCF,NMN,NPC
may be used to declare compiled-in space descriptors.  Please see the
comment on routine MAPPTR for additional instuctions for declaring
spaces. 

NOTE:  These routines are set up to allow for compactification of 
free space & release of excess buffer blocks.  However, the routine
for doing the actual release of excess blocks is not included yet
although the place it is to go is clearly marked (in CPFY).  Therefore,
it is suggested that the flag CPFYOK be left FALSE for the time being.
⊗
; Definitions of fields

;SPACE DESCRIPTOR

	II == 0
	XX	IDFLAG	;Actually a byte; gets put in the ID part of tag word
	XX	MAPRTN	;Routine to be called when marking
	XX	SIZE	;How many words for a value cell in this type block.
	XX	NPERB	;Number of blocks per buffer
	XX	GCFG	;Set if this is a collectable area
	XX	NMIN	;Min number of free blocks to be returned by GC
	XX	NPCT	;Min % of free blocks to be returned by GC
	XX	NXTSID	;Next space descriptor on ID chain
	XX	FFREE	;List of free blocks
	XX	FSTBUF	;Oldest buffer
	XX	LSTBUF	;Newest buffer
	XX	NALLOC	;Number of blocks allocated
	XX	NFREE	;Number of blocks free
	SPCHDR == II	;Number of bytes in a space descriptor

; BUFFER HEADER
	II == 0
	XX	NXTBUF	;Next buffer in this space
	XX	PRVBUF	;Previous buffer in this space
	XX	LSTBLK	;Address of last block in this buffer
	XX	FSTBLK	;Address of first block in this buffer, word 0.
	BUFHDR == II	;Number of bytes in a buffer header

; SMALL BLOCK
	II == 0
	TAG == -1	; ≠ 0 means in use (used by GC)
	TAGID == -2	;Holds an "ID" for this record
	XX	WORD0	;First data word
                        ;Note that if this block is free, the first data
                        ;word is used to maintain a list of free
                        ;blocks. 

; GC METHODS
	II == 0
	XX	METH	;Address of routine to call
	XX	NXTMTH	;Next CG method on chain

; Marking method macro
       .MACRO MMETH ROUT
	ROUT
	0
       .ENDM
; DEFSPC

; Assemble-time spaces
       .IF2
	SIDHED == SIDCHN ;Sets SIDHED to the final value of SIDCHN
       .ENDC

SIDCNT == 0		;Number of assembled-in space descriptors
SIDCHN == 0		;Linkage for assembled-in space descriptors

COMMENT ⊗ Declare assembled-in space descriptors: Makes a space
descriptor.  ID is given the number of the space.  MMRT is the map
routine, SZ the size, NPB the number of blocks per buffer, GCF is set
if the area is not to be collected, NMN is the minimum number of free
blocks that GC should return, NPC is the minimum percent of free
blocks that GC should return.  ⊗

.MACRO DEFSPC ID,MMRT,SZ,NPB,GCF,NMN,NPC
    .IFNDF ID
	SIDCNT==SIDCNT+1
	ID==SIDCNT
    .ENDC
    II==.
    .BLKW SPCHDR/2
	TT	IDFLAG,ID
	TT	MAPRTN,MMRT
	TT	SIZE,SZ
	TT	NPERB,NPB
	TT	GCFG,GCF
	TT	NMIN,NMN
	TT	NPCT,NPC
	TT	NXTSID,SIDCHN
	TT	FFREE,0
	TT	FSTBUF,0
	TT	LSTBUF,0
	TT	NALLOC,0
	TT	NFREE,0
    SIDCHN == II
    .=II+SPCHDR
      .IF2
	.IFGE MAXIDF-ID
	  PUTLOC <ID*2 + SIDTBL>,SIDCHN
	.ENDC
      .ENDC
.ENDM

; DATA AREA

SBEVT:	0		;Interlocking event
MMETHS:	0		;Header of list of marking methods
GCOK:	0		;0 => GC is OK; else count of those opposed to it.
CPFYOK:	0		;Set if compactification is OK
SIDLST:			;List of space descriptor blocks
	.IF1		;Let pass 2 of assemble fix this up
		0
	.ENDC
	.IF2
		SIDHED
	.ENDC

MAXIDF == 30		;Max index into SIDTBL
SIDTBL:	0		;Table of space descriptors for efficiency
	.BLKB MAXIDF
; MAPPTR, MKRTJM, MARKR0, LNKMTH

ROUTINE MAPPTR,<ROUT>	
 
COMMENT ⊗ ROUT takes a single parameter (in R0) which is a pointer to
a small block.  It returns (in R0) a pointer value which is to be
stored back in the pointer cell.  This allows MAPPTR to be called
twice to do essentially different things.  The first time, during
marking, ROUT will be MKROUT.  The second time, during
compactification, it will be something else. 

MAPPTR runs down a list of "marking methods" (MMETHS).  Each method
is assumed to be responsible for some batch of "top level" pointers
(i.e., variables in the user's program that point to small blocks). 
For each pointer it finds, a method should call the routine MARKR0
(via JSR PC).  Thus, each marking method should have the form

 	METH:	R←#<first pointer>
 		WHILE R≠NULL DO
 			BEGIN
 			R0←(R);
 			JSR PC,MARKR0;
 			(R)←R0;
 			R←#<next pointer>;
 			END;
 		RETURN;
 
MARKR0 determines the type of the record (finds its space descriptor).
It then does a 

 		JSR	PC,@MAPRTN(<space>)

MAPRTN takes as a parameter a single block pointer in R0 & returns(in
R0) a pointer to the same block (In the case of compactification,
this may be a different value).  The routine is responsible for
"marking" the block and any pointer subfields of the block.  If there
are no pointer subfields, then the system routine MKRTJM ( JMP
@ROUT(RF) ) may be used.  If there are pointer subfields, then the
mark routine needs to be more complicated:
 
 		IF TAG(R0) THEN RTS PC;	comment if block handled, then return;
 		JSR	PC,@2(RF);	comment calls ROUT;
 		PUSH R;
 		R←R0;
 		∀ <field> | <field> is a pointer subfield of R DO
 			BEGIN
 			R0←<field>
 			JSR	PC,MARKR0;
 			<field>←R0;
 			end;
 		R0←R;
 		POP R;
 		RTS PC;
 
Note: it may be a good idea to change the conventions here a bit to
(1) pass a pointer at a record pointer & (2) let markr0 assume
responsibility for storing the updated pointer.  The advantage of
such a course is that it allows iterative marking of long lists, thus
avoiding possible pdl overflows. 


NOTE: ***** There is a BUG in CPFY.  The test on the tag inside the
maprtn may cause a record to be skipped over that has pointer
subfields to garbage (ie moved records).  Fix this later.
LEAVE CPFY OFF *****
					RHT

EXAMPLE: Consider a CONS cell:

DEFSPC	CNSCLL,CNSMRK,2,100,0,40,20
	II == 0
	XX	CAR
	XX	CDR

; This is the map routine associated with the CONS cell space:
CNSMRK:	TSTB	TAG(R0)		
	BNE	CNSM.X
	JSR	PC,@2(RF)	; calls ROUT
	MOV	R2,-(SP)	; 
	MOV	R0,R2		;SAVE RETN VALUE
	MOV	CAR(R2),R0	; MARK CAR
	JSR	PC,MARKR0
	MOV	R0,CAR(R2)
	MOV	CDR(R2),R0	;MARK CDR
	JSR	PC,MARKR0
	MOV	R0,CDR(R2)
	MOV	R2,R0		;RET VAL BACK
	MOV	(SP)+,R2	;PUT R2 BACK
CNSM.X:	RTS	PC		;RETURN

CELLS:	BLKW	10		;A BLOCK OF 10 CELL POINTERS

;This is the marking method for cells:
MCELLS:	MOV	R2,-(SP)	;
MCL.1:	MOV	#CELLS+20,R2	;WILL LOOP THROUGH
	MOV	-(R2),R0	;PICK UP POINTER
	JSR	PC,MARKR0	;MARK IT
	MOV	R0,(R2)		;PUT POINTER AWAY
	CMP	R0,#CELLS	;DONE YET ?
	BGT	MCL.1		;NOPE
	RTS	RF		;YES

MCLNK:	MMETH	MCELLS		;SPACE FOR LINK (IMPURE CODE)

;; ** next two lines go somewhere into initialization code
	MOV	#MCLNK,R0
	JSR	PC,LNKMTH
;; END OF EXAMPLE

⊗

;MAPPTR:	;(IN CASE YOU HAD FORGOTTEN)
	MOV	R2,-(SP)	;
	MOV	MMETHS,R2	;LIST OF MARKING METHS
	BEQ	MAPRTS		;DONE??
MAPLP:	CALL	@METH(R2),<ROUT(RF)>
	MOV	NXTMTH(R2),R2	;NEXT METHOD
	BNE	MAPLP		;ITERATE
MAPRTS:	MOV	(SP)+,R2	;
	RTS	RF		;RETURN

;The appropriate marking intrinsic for spaces whose blocks contain
;no pointer subfields:
MKRTJM:	JMP	@ROUT(RF)	;

MARKR0:	;This will be called by each marking method:
	TST	R0		;DON'T MARK A NULL
	BEQ	MR0.X		;
	JSR	PC,PTRSID	;GETS SPACE DESCRIPTOR INTO R1
	JSR	PC,@MAPRTN(R1)	;CALL APPROPRIATE MARKING INTRINSIC
MR0.X:	RTS	PC

; Add a method (in R0) to the "MMETHS" list:
LNKMTH:	MOV	MMETHS,NXTMTH(R0)
	MOV	R0,MMETHS
	RTS	PC
; MARKPH, MKROUT

ROUTINE MARKPH		;The marking phase of garbage collection
	MOV	R2,-(SP)	;
	MOV	R3,-(SP)	;
	MOV	SIDLST,R2	;ALL SIZES
	BEQ	MKPHRT		;DONE ALREADY??
MKPH.1:	TST	GCFG(R2)	;A GC SPACE??
	BEQ	MKPH.AD		;NO, GO ON TO NEXT
	MOV	SIZE(R2),R3	;
	INC	R3		;ONE FOR TAG WORD
	ASL	R3		;WORDS TO BYTES
	MOV	FSTBUF(R2),R1	;CLEAR THIS BUFFER
	BEQ	MKPH.AD		;IF THERE IS ONE
MKP.02:	MOV	FSTBLK(R1),R0	;FIRST BLOCK
MKPH.2:	CMP	R0,LSTBLK(R1)	;DONE THIS BUFFER?
	BGT	MKPH.3		;IF SO, GO ON TO NEXT
	CLRB	TAG(R0)		;CLEAR TAG
	ADD	R3,R0		;BUMP POINTER TO NEXT
	BR	MKPH.2		;ITERATE
MKPH.3:	MOV	NXTBUF(R1),R1	;ON TO NEXT BUFFER
	BNE	MKP.02		;IF WE HAVE ONE
MKPH.AD:MOV	NXTSID(R2),R2	;GO ON TO NEXT SPACE
	BNE	MKPH.1		;

	CALL	MAPPTR,<#MKROUT> ;DO THE ACTUAL MARKING
	
MKPHRT:	MOV	(SP)+,R3	;RESTORE
	MOV	(SP)+,R2
	RTS	RF

MKROUT:	MOVB	#377,TAG(R0)	;
	RTS	PC		;

ROUTINE CPFYSP,<SPC>

; Performs all data moving required to compactify one size space

	MOV	R2,-(SP)	;SAVE SOME ACS
	MOV	R3,-(SP)	;
	MOV	R4,-(SP)	;
	MOV	SPC(RF),R2	;SPACE DSCR
	MOV	FSTBUF(R2),R3	;OLDEST
	MOV	LSTBUF(R2),R4	;NEWEST
	JSR	PC,NXF.0	;NEXT FREE INTO 1
				;MAY MODIFY R3
	BEQ	CPFY.2		;NO FREE
	JSR	PC,NXR.0	;GET A RECORD TO MOVE
				;INTO R1 (MAY MUNCH R0)
	BEQ	CPFY.2		;
CPFY.1:	MOV	R1,-(SP)	;SAVE THESE
	MOV	R0,-(SP)	;
	MOVB	#377,TAG(R0)	;
	CLRB	TAG(R1)		;
	MOV	SIZE(R2),R2	;
CPYR:	MOV	(R1)+,(R0)+	;COPY RECORD
	DEC	R2		;COUNT DOWN
	BGT	CPYR		;DONE??
	MOV	SPC(RF),R2	;YES
	MOV	(SP)+,R0	;GET ACS BACK
	MOV	(SP)+,R1	;
	MOV	R0,WORD0(R1)	;POINT AT THIS ONE
	JSR	PC,NXF.NX	;NEXT FREE
	BEQ	CPFY.2
	JSR	PC,NXR.NX	;NEXT RECORD
	BNE	CPFY.1		;PROCESS THAT ONE
CPFY.2:
	MOV	(SP)+,R4	;
	MOV	(SP)+,R3	;
	MOV	(SP)+,R2
	RTS	RF

NXF.0:	MOV	FSTBLK(R3),R0	;FIND A FREE BLOCK
NXF.1:	TSTB	TAG(R0)		;FREE
	BEQ	NXF.4		;YES
NXF.NX:	ADD	SIZE(R2),R0	;LOOK AT NEXT
	ADD	SIZE(R2),R0	;ADD TWICE SINCE WANT TRUE ADDRESS
	TST	(R0)+		;ADD IN TAG WORD OFFSET
	CMP	R0,LSTBLK(R3)	;MORE TO TRY??
	BLE	NXF.1		;TRY AGAIN
	MOV	NXTBUF(R3),R3	;NEXT NEWEST BUFFER
	BEQ	NXF.3		;LOOK THERE
	CMP	R3,R4		;IF NOT TO THE R SUPPLIER
	BNE	NXF.0
NXF.3:	CLR	R0
NXF.4:	MOV	R0,R0		;GET FLAGS CORRECT
	RTS	PC


NXR.0:	MOV	FSTBLK(R4),R0	;FIND A FULL BLOCK
NXR.1:	TSTB	TAG(R0)		;FULL
	BNE	NXF.4		;YES
NXR.NX:	ADD	SIZE(R2),R0	;LOOK AT NEXT
	ADD	SIZE(R2),R0	;ADD TWICE SINCE WANT TRUE ADDRESS
	TST	(R0)+		;ADD IN TAG WORD OFFSET
	CMP	R0,LSTBLK(R4)	;MORE TO TRY??
	BLE	NXR.1		;TRY AGAIN
	MOV	PRVBUF(R4),R4	;NEXT NEWEST BUFFER
	BEQ	NXR.3		;LOOK THERE
	CMP	R3,R4		;IF NOT TO THE R SUPPLIER
	BNE	NXF.0
NXR.3:	CLR	R0
NXR.4:	MOV	R0,R0		;GET FLAGS CORRECT
	RTS	PC
ROUTINE CPFY
	MOV	R2,-(SP)	
	MOV	SIDLST,R2	;LIST OF ALL SIZES
	BEQ	CPFYXX		;NULL LIST??
CPFYLP:	TST	GCFG(R2)	;COLLECTABLE??
	BEQ	CPFYNX		;BR IF NOT
	CALL	CPFYSP,<R2>	;COMPACTIFY THIS SPACE
CPFYNX:	MOV	NXTSID(R2),R2
	BNE	CPFYLP
CPFYXX:	CALL	MAPPTR,<#MUNLNK> ;MUNCH ALL LINKS
	; **** HERE IS THE SPOT WHERE YOU SHOULD WORRY ABOUT
	;      GETTING RID OF EXCESS BUFFER BLOCKS ****
CPFYRT:	MOV	(SP)+,R2	;RETURN
	RTS	RF

;When MUNLNK is called, R0 is a pointer to a block which may or may not have
;been moved by CPFY.  If it has been moved, then TAG(R0) will have
;been set to 0, and WORD0(R0) will point at the correct block.
;The routine will always return a pointer to the "real" block,
;so MARKR0 will return a correct value.

MUNLNK:	TSTB	TAG(R0)		;DID WE MOVE IT ??
	BNE	MUNRTS		;
	MOV	WORD0(R0),R0	;YES, PUT NEW POINTER IN PLACE
MUNRTS:	RTS	PC		;

; SWEEP

ROUTINE SWEEP		;The sweep phase of garbage collection
	MOV	R2,-(SP)	;
	MOV	SIDLST,R2	;LIST OF SIZES
	BEQ	SWP.X
SWP.LP:	JSR	PC,SWP.		;GO SWEEP ONE AREA
	MOV	NXTSID(R2),R2	;ITERATE
	BNE	SWP.LP		;
SWP.X:	MOV	(SP)+,R2	;
	RTS	RF		;

ROUTINE SWEEP1,<SPCC>	
	MOV	R2,-(SP)	;SAVE REGISTERS
	MOV	SPCC(RF),R2	;GET A SPACE
	JSR	PC,SWP.		;SWEEP ONE AREA
SWP.XX:	MOV	(SP)+,R2	
	RTS	RF

SWP.:	;R2 = LOC[Space descriptor]
	TST	GCFG(R2)	;IS THIS SPACE FOR SWEEPING??
	BNE	SWP.00		;
	RTS	PC		;NO
SWP.00:	MOV	R3,-(SP)	;YES
	MOV	R4,-(SP)	;
	CLR	FFREE(R2)	;WILL BUILD A REAL FREE LIST
	CLR	NFREE(R2)	;SINCE WE WILL FIX COUNTS
	CLR	NALLOC(R2)	;
	MOV	FSTBUF(R2),R3	;OLDEST BUFFER
	BEQ	SWP.3		;IF ANY
	MOV	SIZE(R2),R4	;COMPUTE SIZE
	INC	R4		;IN BYTES OF WHOLE THING
	ASL	R4		;
SWP.01:	MOV	FSTBLK(R3),R0	;GET A BLK
SWP.1:	TSTB	TAG(R0)		;ALLOCATED?
	BEQ	SWP.1N		;NO
	INC	NALLOC(R2)	;YES
	BR	SWP.2
SWP.1N:	INC	NFREE(R2)	;LINK UP A FREE
	MOV	FFREE(R2),WORD0(R0)
	MOV	R0,FFREE(R2)
SWP.2:	ADD	R4,R0		;BUMP POINTER TO NEXT IN BUFFER
	CMP	R0,LSTBLK(R3)	;DONE BUFFER??
	BLE	SWP.1		;NO
	MOV	NXTBUF(R3),R3	;YES GO ON TO NEXT
	BNE	SWP.01		;IF THERE IS ONE
SWP.3:	CMP	NFREE(R2),NMIN(R2)	;NEED MORE??
	BGT	SWP.5		;AT LEAST HAVE MIN NUMBER
SWP.4:	CALL	ADDBUF,<R2>	;NO, ADD A BUFFER FULL
	BR	SWP.3		;AND TRY AGAIN
SWP.5:	MOV	NFREE(R2),R0	;SEE IF HIGH ENOUGH PERCENTAGE
	ADD	NALLOC(R2),R0	;OF FREES
	MUL	NPCT(R2),R0	; 
	DIV	#144,R0		; NPCT*(NFREE+NALLOC)/=100
	CMP	NFREE(R2),R0	;
	BGT	SWP.6		;IF DONT HAVE ENOUGH
	CALL	ADDBUF,<R2>	;GET A BUFFER LOAD
	BR	SWP.5		;AND TRY AGAIN
SWP.6:	MOV	(SP)+,R4	;RESTORE
	MOV	(SP)+,R3
	RTS	PC

; GC, NOGC, YESGC

ROUTINE GC
	CALL	MARKPH		;MARK EVERYONE
	TST	CPFYOK		;IF DONT WANT COMPACTIFICATION
	BEQ	SWPPIT		;THEN DONT DO IT
	CALL	CPFY		;COMPACTIFY
SWPPIT:	CALL	SWEEP		;SWEEP UP LOOSE GARBAGE
GCRET:	RTS	RF

NOGC:
COMMENT ⊗ Called by anyone who has entered that stage of code
during which he does not want garbage collect to happen.  ⊗
	EVWAIT	SBEVT		;Grab exclusion
	INC	GCOK		;Increment the count of those who say nay
	EVSIG	SBEVT		;Release exclusion
	RTS	PC		;Done

YESGC:
COMMENT ⊗ Called by anyone who has exited that stage of code
during which he does not want garbage collect to happen.  ⊗

	EVWAIT	SBEVT		;Grab exclusion
	DEC	GCOK		;Remove the effect we did in NOGC.
	EVSIG	SBEVT		;Release exclusion
	BGT	YGC1		;Reasonable?
	HALERR	YGC2		;No
YGC1:	RTS	PC		;Yes.
YGC2:	ASCIE	</GCOK IS NEGATIVE/>
; GETSBK, GETBLK, GETSID, PTRSID

GETSBK:	
;
;	MOV	[SPACE DESCRIPTOR],R0
;	JSR	PC,GETSBK
;	<RETURNS WITH A BLOCK IN R0>
;
	MOV	R0,R1			
GETBL3:	EVWAIT	SBEVT			;CRITICAL REGION STARTS
GETBL1:	TST	R1			;
	BEQ	GETBER			;CONSISTENCY CHECK
	MOV	FFREE(R1),R0		;R0 ← FIRST FREE BLOCK
	BNE	GETBLX			;DID WE GET ONE
	MOV	R1,-(SP)		;NO,
	TST	GCFG(R1)		;IS GC OK FOR THIS AREA?
	BEQ	GETADB			;NO, MUST ADD
	TST	GCOK			;IS GARBAGE COLLECTION OK AT ALL
	BNE	GETADB			;no.
	; Must be able to get GNEVT and INTEVT.  Don't need them right now, though.
	EVTST	GNEVT			;We must have this available.
	BCS	GETADB			;
	EVSIG	GNEVT			;
	EVTST	INTEVT			;We must have this available.
	BCS	GETADB			;
	EVSIG	INTEVT			;
	BR 	GETGC			;
GETADB:	CALL	ADDBUF,<R1>		;NO, JUST GET A BUFFER
	BR 	GETBXX			;
GETGC:	CALL	GC			;YES, GC
GETBXX:	MOV	(SP)+,R1		;
	BR	GETBL1
GETBLX:	MOV	WORD0(R0),FFREE(R1)	;NEW FIRST FREE BLOCK
	INC	NALLOC(R1)		;ADJUST COUNTS
	DEC	NFREE(R1)
	MOVB	IDFLAG(R1),TAGID(R0)	;REMEMBER WHAT IT IS
	MOV	R0,-(SP)		;SAVE POINTER TO BLOCK
	MOV	SIZE(R1),R1		;WORD COUNT
GETB.C:	CLR	(R0)+			;CLEAR A WORD
	DEC	R1			;COUNT DOWN
	BGT	GETB.C			;UNTIL DONE
	MOV	(SP)+,R0		;RETURN VALUE BACK
	EVSIG	SBEVT			;END OF CRITICAL SECTION
	RTS	PC

;
;	MOV	#ID,R0
;	JSR	PC,GETBLK
;
GETBLK:	JSR	PC,GETSID		;SET UP SPC DSCR IN R1
	BR	GETBL3

GETBER:	HALERR	GERMSG
	CLR	R0
	RTS	PC

GERMSG:	ASCIE	/ATTEMPT TO ALLOCATE RECORD WITHOUT GIVING DESCRIPTOR/

GETSID:
;  Given the TAGID of a space in R0, returns LOC[space descriptor] in R1.
	MOV	R0,R1
	CMP	R0,#MAXIDF		;IN THE TABLE?
	BGT	GETS.1			;NO
	ASL	R1
	MOV	SIDTBL(R1),R1		;YES
GETS.X:	RTS	PC			;
GETS.1:	MOV	SIDLST,R1		;SEARCH CHAIN
	BEQ	GETS.X
GETS.2:	CMP	R0,IDFLAG(R1)		;THIS ONE??
	BNE	GETS.X			;YES
	MOV	NXTSID(R1),R1		;NO, TRY NEXT
	BNE	GETS.2
	RTS	PC

PTRSID:
; Given a pointer to a block in R0, returns LOC[space descriptor] in R1.
; Does not destroy R0.
	MOV	R0,-(SP)		;SINCE GETSID WILL MUNCH
	MOVB	TAGID(R0),R0		;THE ID FLAG
	BIC	#177400,R0		;The sign was extended.  Clear it.
	JSR	PC,GETSID		;GET SID INTO R1
	MOV	(SP)+,R0		;GET PTR BACK
	RTS	PC
; FREBLK, FRESBK

FREBLK:
    COMMENT ⊗ To free a block whose descriptor is not known:
            MOV     BLOCK,R0        ;R0 ← Block to free
            JSR     PC,FREBLK
    ⊗
	MOV	SIDLST,R1	;FIND THE SPACE
	BEQ	FREBER		;THIS CAME FROM
FREB.1:	CMPB	TAGID(R0),IDFLAG(R1) ;WAS IT THIS AREA
	BEQ	FREB.		;YES
	MOV	NXTSID(R1),R1	;NO. LOOK AT NEXT
	BNE	FREB.1		;ITERATE
FREBER:	HALERR	FRERMS
	RTS	PC
FREB.:	EVWAIT	SBEVT		;CRITICAL REGION STARTS
	MOV	FFREE(R1),WORD0(R0);FOUND THE AREA, PUT ON FREE CHAIN
	MOV	R0,FFREE(R1)
	INC	NFREE(R1)	;ADJUST COUNTS
	DEC	NALLOC(R1)
	CLRB	TAG(R0)		;JUST FOR RANDOMNESS
	EVSIG	SBEVT		;END OF CRITICAL REGION
	RTS	PC		;DONE
FRERMS:	ASCIE	/ATTEMPT TO DELETE A BLOCK FROM AN AREA I CANNOT FIND/

FRESBK:
    COMMENT ⊗  To free a block whose descriptor is known:
            MOV     BLOCK,R0         ;R0 ← block to free
            MOV     #SPCDSC,R1       ;R1 ← space descriptor
            JSR     PC,FRESBK
    ⊗

	CMPB	TAGID(R0),IDFLAG(R1)	;BE SURE THIS IS OK
	BEQ	FREB.		;WE WIN
	HALERR	FRBER2
	BR	FREB.		;DO IT ANYHOW IF CONTINUES IT

FRBER2:	ASCIE	/ID DISAGREEMENT FOR FRESBK/
; NEWSPC, SETSPC

COMMENT ⊗ Create a space descriptor.  SZ is the size, IDF the IDFLAG,
NPB the number of blocks per buffer, GCF is set if the area is not to
be collected, NMN is the minimum number of free blocks that GC should
return, NPC is the minimum percent of free blocks that GC should
return.  R0 returns the address of the new space descriptor.  ⊗
ROUTINE NEWSPC,<SZ,IDF,NPB,GCF,NMN,NPC>

	MOV	#SPCHDR/2,R0	;GET A BLOCK OF CORE
	JSR 	PC,GTFREE
	MOV	SZ(RF),SIZE(R0) ;REMEMBER HOW BIG
	MOV	NPB(RF),NPERB(R0) ;
	MOV	IDF(RF),IDFLAG(R0) ;
	MOV	NMN(RF),NMIN(R0);
	MOV	NPC(RF),NPCT(R0);
	MOV	SIDLST,NXTSID(R0)  ;LINK ONTO ID CHAIN
	MOV	R0,SIDLST
NEWS.1:	MOV	IDFLAG(R0),R1	;R1 ← space number
	CMP	R1,#MAXIDF	;WILL IT FIT INTO TABLE
	BGT	NEWS.2		;
	ASL	R1		;YES
	MOV	R0,SIDTBL(R1)	;PUT INTO TABLE
NEWS.2:	CLR	FFREE(R0)	;Zero out other things
	CLR	FSTBUF(R0)
	CLR	LSTBUF(R0)
	CLR	NALLOC(R0)
	CLR	NFREE(R0)
	RTS	RF		;RETURN

COMMENT ⊗ Initialize a space descriptor.  SPCADR is its address.  It
will be linked into the ID chanin, put in the SIDTBL if it fits, and
it will be cleared of all buffers.  ⊗
ROUTINE SETSPC,<SPCADR>
	MOV	SPCADR(RF),R0	;
	BR	NEWS.1		;GO INITIALIZE ALL NON-CONSTANT THINGS
; ADDBUF

ROUTINE ADDBUF,<SPACE>
;ADDS ANOTHER BUFFER TO THE NAMED SPACE
	MOV	R2,-(SP)		;SAVE A REGISTER
	MOV	R3,-(SP)
	MOV	SPACE(RF),R2
	MOV	SIZE(R2),R1		;CALCULATE WORD REQUIREMENTS
	INC	R1			;ONE WORD OVERHEAD FOR TAG & ID BYTES
	MOV	R1,-(SP)		;WILL NEED THIS LATER
	MUL	NPERB(R2),R1		;SIZE*NUMBER OF BLOCKS
	ADD	#BUFHDR/2,R1		;
	MOV	R1,R0			;
	JSR	PC,GTFREE		;GET A BLOCK
	MOV	LSTBUF(R2),R1		;LINK ONTO CHAIN
	MOV	R1,PRVBUF(R0)		;LINK BACK
	BEQ	ADB.01			;
	MOV	R0,NXTBUF(R1)		;AND PERHAPS FORWARD
	BR	ADB.1			;
ADB.01:	MOV	R0,FSTBUF(R2)		;IF WAS NO LSTBUF, THEN THIS IS FSTBUF
ADB.1:	CLR	NXTBUF(R0)		;CLEAN UP
	MOV	R0,LSTBUF(R2)		;NEW NEWEST BLOCK
	MOV	R0,R3			;
	ADD	#2+BUFHDR,R3		;POINTER AT FIRST BLOCK
	MOV	R3,FSTBLK(R0)		;REMEMBER IT
	MOV	NPERB(R2),R1		;
	ASL	(SP)			;NUMBER OF BYTES TO STEP BY
	SUB	(SP),R3			;TO UNDO FIRST ADD

ADB.2:	ADD	(SP),R3
	INC	NFREE(R2)		;ONE MORE FREE
	CLRB	TAG(R3)			;CLEAR TAG
	MOVB	IDFLAG(R2),TAGID(R3)	;SET TYPE ID
	MOV	FFREE(R2),WORD0(R3)	;CONS ONTO FREE LIST
	MOV	R3,FFREE(R2)		;
	DEC	R1			;ITERATE
	BGT	ADB.2			;IF ANY LEFT

	MOV	R3,LSTBLK(R0)		;R3 NOW POINTS AT LAST BLOCK
	TST	(SP)+			;POP
	MOV	(SP)+,R3		;RESTORE ACS
	MOV	(SP)+,R2
	RTS	RF

; Standard spaces, SBINIT, Marking methods: MCELL, MARKQ

;Recall that MACRO DEFSPC ID,MMRT,SZ,NPB,GCF,NMN,NPC

SCASPC:	DEFSPC	SCLID,MKRTJM,2,10,1,4,15
VCTSPC:	DEFSPC	VCTID,MKRTJM,10,10,1,4,15
TRNSPC:	DEFSPC	TRNID,MKRTJM,40,4,1,2,15
CELSPC:	DEFSPC	CELID,MKRTJM,2,10,1,4,15
ENVSPC:	DEFSPC	ENVID,MKRTJM,30,3,1,1,10

COMMENT ⊗ Thus SCLID=1, VCTID=2, TRNID=3 ⊗

ROUTINE SBINIT
; Initializes the small block allocator with the standard spaces.
	EVMAK			;Initialize the small block interlock event
	MOV (SP)+,SBEVT		;
	EVSIG SBEVT		;
	MOV #SIDHED,SIDLST	;
	CLR GCOK		;Garbage collect initially OK.
	CLR CPFYOK		;
	MOV #SIDHED,R2		;R2 ← First space
	BEQ SBIN1		;If any
SBIN2:	CALL SETSPC,<R2>	;Initialize this space
	MOV NXTSID(R2),R2	;R2 ← Next space
	BNE SBIN2		;If any
SBIN1:	CLR MMETHS		;Initialize the marking methods
	MOV #MGNDSM,R0		;Link in the GNODE marking method
	JSR PC,LNKMTH		;
	MOV #MINTSM,R0		;Link in the interpreter stack marking method
	JSR PC,LNKMTH		;
	RTS RF

MGNDSM:	MMETH MGNDS		;In file GRAPHS.PAL
	
MINTSM:	MMETH MINTS		;In file INTERP.PAL

MCELL:	
COMMENT ⊗ Marking method for a cell list.  Takes pointer to list in
R0, and marks all the way down, and returns pointer in R0, since
compactification may move it.  ⊗
	TST R0			;Empty?
	BEQ MCELL1		;Yes.
	MOV R2,-(SP)		;Save R2
	JSR PC,MARKQ		;Mark cell
	MOV R0,R2		;Save new pointer
	MOV CDR(R2),R0		;Mark the rest of the list recursively
	JSR PC,MCELL		;
	MOV R0,CDR(R2)		;replace pointer.
	MOV R2,R0		;Restore R0 ← pointer
	MOV (SP)+,R2		;Restore R2
MCELL1:	RTS PC			;Done

MARKQ:
COMMENT ⊗ R0 holds LOC[small block].  Mark it if it is really a small
block; but be careful, since it may be a constant.  Return it in R0,
since compactification may have moved it.  ⊗
	CMP R0,#FREEST	;Make sure that it points into free storage.
	BLE MARKQ1	; (it may be a program constant)
	CMP R0,#FREEND	;
	BGE MARKQ1	;
	JSR PC,MARKR0	;Get it marked
MARKQ1:	RTS PC		;Done

.IFNZ	SMBDBG		;Test routine


FSTEST:	CALL	SBINIT
	MOV	#20,R2
	MOV	#VCTARA,R3
FST.1:	MOV	#VCTID,R0
	JSR	PC,GETBLK
FST.2:	MOV	R0,(R3)+
	DEC	R2
	BGT	FST.1
FST.3:	MOV	#13,R2
FST.4:	MOV	-(R3),R0
	JSR	PC,FREBLK
	DEC	R2
	BGT	FST.4
FST.5:	MOV	#17,R2
FST.6:	MOV	#VCTID,R0
	JSR	PC,GETBLK
	MOV	R0,(R3)+
	DEC	R2
	BGT	FST.6
FST.10:	MOV	#TSTMTH,R0
	JSR	PC,LNKMTH
	MOV	R3,VCTUB
	SUB	#2,VCTUB
	MOV	#VCTARA,VCTLB
	MOV	#-1,GCOK
	CALL	GC
FST.11:	MOV	#10,R2
FST.12:	MOV	#VCTSPC,R0
	JSR	PC,GETSBK
	DEC	R2
	BGT	FST.12

	HALERR	DNMSG

DNMSG:	ASCIE	</
WELL HOW DID WE DO?/>

VCTARA:	.BLKW	200
VCTUB:	0
VCTLB:	0

TSTMTH:	MMETH	TSTRTN

ROUTINE TSTRTN,<RTN>
	MOV	R2,-(SP)
	MOV	VCTLB,R2
TST.R1:	CMP	R2,VCTUB
	BGT	TSTRTS
	MOV	(R2),R0
	JSR	PC,MARKR0
	MOV	R0,(R2)+
	BR	TST.R1
TSTRTS:	MOV	(SP)+,R2
	RTS	RF

.ENDC
; Known bugs

COMMENT ⊗ Garbage collect will fail to mark, and therefore wrongfully
collect, those small blocks which have just been allocated and are
sitting in registers somewhere.  The proper fix to this is that
GETSBK and GETBLK should turn on one level of garbage collect
inhibition, and let the caller turn it off when he has stowed away
the pointer in some place known to the marking routines.  A similar
problem could occur when someone removes a pointer from the known
places before he is really finished with the small block.  This is
fixed only by careful identification and rectification of such pieces
of code.  

When marking those things pointed to by interpeter stacks, the MINT
routine looks for a zero entry on the stack.  This could fail, or get
more than wanted. 
⊗